home *** CD-ROM | disk | FTP | other *** search
/ Aminet 1 (Walnut Creek) / Aminet - June 1993 [Walnut Creek].iso / aminet / dev / lang / sbp3_1e.lzh / TRIANGLE.PL < prev    next >
Text File  |  1991-10-31  |  5KB  |  163 lines
  1. /* From the book PROLOG PROGRAMMING IN DEPTH
  2.    by Michael A. Covington, Donald Nute, and Andre Vellino.
  3.    Copyright 1988 Scott, Foresman & Co.
  4.    Non-commercial distribution of this file is permitted. */
  5. /* Modified for Quintus Prolog by Andreas Siebert */
  6.  
  7. /* TRIANGLE.PL */
  8.  
  9. /*
  10.  * Some parts of this program are repetitious because
  11.  * table lookup is faster than computation, and CPU time
  12.  * is at a premium. Slower but more concise routines
  13.  * could of course be substituted.
  14.  */
  15.  
  16. /*
  17.  * Main routines
  18.  */
  19.  
  20. triangle(N) :-   /* N is which peg to leave out */
  21.      set_peg(0,N,[1,1,1,1,1,1,1,1,1,1,1,1,1,1,1],FirstBoard),
  22.      triangle_solver(14,[FirstBoard],Solution),
  23.      nl,nl,
  24.      fast_reverse(Solution,ReversedSolution),
  25.      show_triangle(ReversedSolution).
  26.  
  27. triangle_solver(1,Solution,Solution).
  28.  
  29. triangle_solver(N,[OldBoard|PastBoards],Solution) :-
  30.      write(N), put(32),
  31.      legal_jump(OldBoard,NewBoard),
  32.      M is N - 1,
  33.  
  34. triangle_solver(M,[NewBoard,OldBoard|PastBoards],Solution).
  35.  
  36. legal_jump(OldBoard,NewBoard) :- jump(X,Y,Z),
  37.                                  \+ peg(Z,OldBoard),
  38.                                  peg(X,OldBoard),
  39.                                  peg(Y,OldBoard),
  40.                                  set_peg(0,X,OldBoard,W1),
  41.                                  set_peg(0,Y,W1,W2),
  42.                                  set_peg(1,Z,W2,NewBoard).
  43.  
  44. /*
  45.  * List reversal routine
  46.  */
  47.  
  48. fast_reverse(X,Y) :- fast_reverse_aux(X,Y,[]).
  49.  
  50. fast_reverse_aux([],X,X).
  51.  
  52. fast_reverse_aux([H|T],Result,Temp) :-
  53. fast_reverse_aux(T,Result,[H|Temp]).
  54.  
  55. /*
  56.  * Legal jumps -- listed as a table for fast lookup
  57.  */
  58.  
  59. jump(1,2,4).        jump(1,3,6).        jump(2,4,7).
  60. jump(2,5,9).        jump(3,5,8).        jump(3,6,10).
  61. jump(4,2,1).        jump(4,5,6).        jump(4,8,13).
  62. jump(4,7,11).       jump(5,8,12).       jump(5,9,14).
  63. jump(6,3,1).        jump(6,5,4).        jump(6,9,13).
  64. jump(6,10,15).      jump(7,4,2).        jump(7,8,9).
  65. jump(8,5,3).        jump(8,9,10).       jump(9,5,2).
  66. jump(9,8,7).        jump(10,6,3).       jump(10,9,8).
  67. jump(11,7,4).       jump(11,12,13).     jump(12,8,5).
  68. jump(12,13,14).     jump(13,8,4).       jump(13,9,6).
  69. jump(13,12,11).     jump(13,14,15).     jump(14,9,5).
  70. jump(14,13,12).     jump(15,10,6).      jump(15,14,13).
  71.  
  72. /*
  73.  * A separate rule for each hole to check
  74.  * whether it has a peg in it
  75.  */
  76.  
  77. peg(1,[1,_,_,_,_,_,_,_,_,_,_,_,_,_,_]).
  78. peg(2,[_,1,_,_,_,_,_,_,_,_,_,_,_,_,_]).
  79. peg(3,[_,_,1,_,_,_,_,_,_,_,_,_,_,_,_]).
  80. peg(4,[_,_,_,1,_,_,_,_,_,_,_,_,_,_,_]).
  81. peg(5,[_,_,_,_,1,_,_,_,_,_,_,_,_,_,_]).
  82. peg(6,[_,_,_,_,_,1,_,_,_,_,_,_,_,_,_]).
  83. peg(7,[_,_,_,_,_,_,1,_,_,_,_,_,_,_,_]).
  84. peg(8,[_,_,_,_,_,_,_,1,_,_,_,_,_,_,_]).
  85. peg(9,[_,_,_,_,_,_,_,_,1,_,_,_,_,_,_]).
  86. peg(10,[_,_,_,_,_,_,_,_,_,1,_,_,_,_,_]).
  87. peg(11,[_,_,_,_,_,_,_,_,_,_,1,_,_,_,_]).
  88. peg(12,[_,_,_,_,_,_,_,_,_,_,_,1,_,_,_]).
  89. peg(13,[_,_,_,_,_,_,_,_,_,_,_,_,1,_,_]).
  90. peg(14,[_,_,_,_,_,_,_,_,_,_,_,_,_,1,_]).
  91. peg(15,[_,_,_,_,_,_,_,_,_,_,_,_,_,_,1]).
  92.  
  93. /*
  94.  * A separate rule for each hole to
  95.  * insert or remove a peg
  96.  */
  97.  
  98. set_peg(X,1,[_,B,C,D,E,F,G,H,I,J,K,L,M,N,O],
  99.             [X,B,C,D,E,F,G,H,I,J,K,L,M,N,O]).
  100. set_peg(X,2,[A,_,C,D,E,F,G,H,I,J,K,L,M,N,O],
  101.             [A,X,C,D,E,F,G,H,I,J,K,L,M,N,O]).
  102. set_peg(X,3,[A,B,_,D,E,F,G,H,I,J,K,L,M,N,O],
  103.             [A,B,X,D,E,F,G,H,I,J,K,L,M,N,O]).
  104. set_peg(X,4,[A,B,C,_,E,F,G,H,I,J,K,L,M,N,O],
  105.             [A,B,C,X,E,F,G,H,I,J,K,L,M,N,O]).
  106. set_peg(X,5,[A,B,C,D,_,F,G,H,I,J,K,L,M,N,O],
  107.             [A,B,C,D,X,F,G,H,I,J,K,L,M,N,O]).
  108. set_peg(X,6,[A,B,C,D,E,_,G,H,I,J,K,L,M,N,O],
  109.             [A,B,C,D,E,X,G,H,I,J,K,L,M,N,O]).
  110. set_peg(X,7,[A,B,C,D,E,F,_,H,I,J,K,L,M,N,O],
  111.             [A,B,C,D,E,F,X,H,I,J,K,L,M,N,O]).
  112. set_peg(X,8,[A,B,C,D,E,F,G,_,I,J,K,L,M,N,O],
  113.             [A,B,C,D,E,F,G,X,I,J,K,L,M,N,O]).
  114. set_peg(X,9,[A,B,C,D,E,F,G,H,_,J,K,L,M,N,O],
  115.             [A,B,C,D,E,F,G,H,X,J,K,L,M,N,O]).
  116. set_peg(X,10,[A,B,C,D,E,F,G,H,I,_,K,L,M,N,O],
  117.              [A,B,C,D,E,F,G,H,I,X,K,L,M,N,O]).
  118. set_peg(X,11,[A,B,C,D,E,F,G,H,I,J,_,L,M,N,O],
  119.              [A,B,C,D,E,F,G,H,I,J,X,L,M,N,O]).
  120. set_peg(X,12,[A,B,C,D,E,F,G,H,I,J,K,_,M,N,O],
  121.              [A,B,C,D,E,F,G,H,I,J,K,X,M,N,O]).
  122. set_peg(X,13,[A,B,C,D,E,F,G,H,I,J,K,L,_,N,O],
  123.              [A,B,C,D,E,F,G,H,I,J,K,L,X,N,O]).
  124. set_peg(X,14,[A,B,C,D,E,F,G,H,I,J,K,L,M,_,O],
  125.              [A,B,C,D,E,F,G,H,I,J,K,L,M,X,O]).
  126. set_peg(X,15,[A,B,C,D,E,F,G,H,I,J,K,L,M,N,_],
  127.              [A,B,C,D,E,F,G,H,I,J,K,L,M,N,X]).
  128.  
  129. /*
  130.  * Routines to display the solution
  131.  */
  132.  
  133. show_triangle([]).
  134.  
  135. show_triangle([X|Y]) :-
  136.      show_board(X),
  137.      show_triangle(Y).
  138.  
  139. show_board([P1,P2,P3,P4,P5,P6,P7,P8,P9,P10,P11,P12,P13,P14,P15]):-
  140.      write('    '), show_peg(P1), nl,
  141.      write('   '), show_peg(P2), show_peg(P3), nl,
  142.      write('  '), show_peg(P4), show_peg(P5),
  143.           show_peg(P6), nl,
  144.      write(' '), show_peg(P7), show_peg(P8),
  145.           show_peg(P9), show_peg(P10), nl,
  146.      show_peg(P11), show_peg(P12), show_peg(P13),
  147.           show_peg(P14), show_peg(P15), nl,
  148.      write('Press Return. '),
  149.      get0(_),
  150.      nl, nl.
  151.  
  152. show_peg(X) :- write(X), write(' ').
  153.  
  154. %% Starting query
  155.  
  156.  
  157. start :-
  158.   write('Which peg do you wish to leave out?'),nl,
  159.   write('Type the number (1-15) followed by a period.'),nl,
  160.   read(N),
  161.   triangle(N).
  162. 
  163.